SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00012 1 08-24-9413:23ALL IAN LIN **APPENDING EXE** SWAG9408 ½ sñ 12 èo {πThere's a problem here. You can append the binary data but that won't makeπcode from both EXE files work. Either the first one will work, ignoringπthe code from the second one, or the whole thing will turn into trash.ππHowever, if you still want to try it, go ahead. Here are 3 untested byπcompiling file copying programs that will only append IT2.EXE to the end ofπIT.EXE. You'll be required to make or copy files called IT.EXE and IT2.EXEπfor the use of this simple demonstration program.π}ππProgram BCopy1;πuses objects;πvarπ f,f2:tdosstream;πbeginπ f.init ('IT.EXE',stopen);π f.seek (f.getsize);π f2.init ('IT2.EXE',stopen);π f.copyfrom(f2,f2.getsize);π f.done;π f2.done;πend.ππProgram BCopy2;πvarπ f,f2:file;π blocks:longint;π bytes:word;π buffer:array [1..2048] of byte;πbeginπ assign(f,'IT.EXE');π assign(f2,'IT2.EXE');π reset(f,1);π reset(f2,1);π seek(f,filesize(f));π bytes:=filesize(f2);π blocks:=bytes div 2048;π bytes:=bytes mod 2048;π while blocks>0 do beginπ blockread(f2,buffer,sizeof(buffer));π blockwrite(f,buffer,sizeof(buffer));π dec(blocks);π end;π if bytes>0 then beginπ blockread(f2,buffer,bytes);π blockwrite(f,buffer,bytes);π end;π close(f);π close(f2);πend.ππProgram BCopy3;πuses dos;πbeginπ swapvectors;π exec(getenv('comspec'),'/c copy /b it.exe+it2.exe it.exe');π swapvectors;πend.ππ 2 08-24-9413:27ALL FRANK DIACHEYSN Procedure Calls SWAG9408 C╨ε 9 èo {π Coded By Frank Diacheysn Of Gemini Softwareππ PROCEDURE CALLFUNCTIONππ Input......: UserRoutine = Pointer To The Routine To Callπ : NA = String To Pass To <UserRoutine>π :π :π :ππ Output.....: Noneπ :π :π :π :ππ Example....: PROCEDURE CALLME(Str:STRING);π : BEGINπ : WriteLn(Str);π : END;π :π : MyPointer := @CallMe;π : CallFunction(MyPointer,'Calling You!');ππ Description: Used To Call A Function Or A Procedure, Mainly Aπ : Procedure, Since Output Of The Function Can't Beπ : Returned.π :π :ππ}πPROCEDURE CALLFUNCTION(UserRoutine:POINTER; NA:STRING);π PROCEDURE InsideCallFunction(NA:STRING);π INLINE( $FF/$5E/<UserRoutine );πBEGINπ InsideCallFunction(NA);πEND;π 3 08-24-9413:28ALL J.P KARRELL Config File SWAG9408 4å∩¿ 26 èo {π >Can anyone give me an idea of how to use a config file in my programs.π >Such as an easy one, I am writing a program for my BBS in which thisπ >program will Copy files to another directory. I know I could put theπ >directory from and to in the code itself, but what I want to accomplishπ >is to use a Configuration file to read the from directory and toπ >directory. This is so the program can be used anywhere. Can someoneπ >please help me with this?ππI posted a unit I wrote a day or so ago which can be modified to do this.πHere it is again (extensively modified to support an ASCII configurationπfile):ππNotes: Change the CFGKEYS constants to the keywords you want your programπto recognize (remember to change the CONFIGOPTIONS constant also).ππ}ππUnit CFG_DEF;ππInterface uses Dos; { Dos unit is needed for FindFirst }ππConstππCONFIGFILE = 'YOURFILE.CFG';πCONFIGOPTIONS = 5;πCFGKEYS : array[1..CONFIGOPTIONS] of string = ('YOUR',π 'CONFIG',π 'OPTIONS',π 'GO',π 'HERE');ππProcedure Read_Cfg_File;ππImplementation {----------------------------------------------}ππFunction Findfile(searchkey : string) : boolean;π var srec : searchrec;πbeginπ findfirst(searchkey,anyfile, srec);π FindFile := (doserror = 0);πend;ππFunction Uppercase(st : string) : string;π var loop : byte;πbeginπ for loop := 1 to length(st) do st[loop] := upcase(st[loop]);π uppercase := st;πend;ππProcedure Read_Cfg_File;π var f :text; i, j, loop : byte; line, key, command : string;π Result_Table : array[1..CONFIGOPTIONS] of boolean;πbeginπfillchar(Result_Table,sizeof(Result_Table),false);πcommand := #0;πline := #0;πkey := #0;ππ{$I-}πassign(f,CONFIGFILE);πreset(f);π{$I+}π{CheckError(IOResult,CFGFILE); <--- Add your own error checking here asπ my CheckError procedure is not includedπ in this snippet. }π while not EOF(f) do begin {while}π readln(f,line);ππ if (copy(line,1,1) <> #59) andπ (copy(line,1,1) <> #32) then begin { ignore lines preceeded with aπ comment delimiter - usually #59π (IE: ';')}π j := pos(#32,line);ππ if j = 0 then j := length(line)+1;π key := copy(line,1,j-1);π delete(line,1,j);π i := pos(#59,line);ππ if i = 0 then i := length(line)+1;ππ command := copy(line,1,i-1);π i := pos(#32,command);π if i <> 0 then delete(command,i,length(command)-(i-1));ππ for loop := 1 to CONFIGOPTIONS do begin {loop}π if Uppercase(key) = CFGKEYS[loop] then begin {if}π Result_Table[loop] := true;π case loop of {case}π 1 : beginπ end;π 2 : beginπ end;π 3 : beginπ end;π 4 : beginπ end;π 5 : beginπ end;π end; {case}π end; {if}π end; {loop}π end; {if}π end; {while}πclose(f);πend; {proc}ππend. {unit}π 4 08-24-9413:30ALL WIM VAN DER VEGT DBase III Routines SWAG9408 C┘╛¥ 283 èo {---------------------------------------------------------}π{ Unit : Dbase III Access Routines }π{ Auteur : Ir. G.W. van der Vegt }π{ Hondsbroek 57 }π{ 6121 XB Born }π{---------------------------------------------------------}π{ Datum .tijd Revisie }π{ 910701.2130 Creatie. }π{ 910702.1000 Minor Errors Corrected }π{ Replace, Append & Pack Added }π{ 910706.2400 dbrec on the Heap (recsize max 64kB-16) }π{ Uppercase Conversion in Bd3_fileno }π{ Optional Halt on (fatal) Errors }π{ 910710.1500 Memo Field Support }π{ 910715.2330 Field2num bug fixed (leading sp. removed) }π{ 910960.1130 Fieldno Out of range detection }π{ 920116.1000 Two minor bugs fixed }π{ 920124.2200 Header updated when file is closed, }π{ Db3_Seekbof & Db3_Seekeof added }π{ Db3_Findfirst & Db3_Findnext implemented }π{ for wildcard search of records }π{ Db3_soudex & Db3_field2soundex for Soundex}π{ code (sound alike) operations }π{ Db3_firstsoudex & Db3_nextsoundex for }π{ soundex search on a field }π{ 920127.1300 Dbase Slack Filespace Detection & }π{ Correction }π{ 920129.2115 Trailing spaces remover in Db3_field2str }π{ Seek after truncate in Db3_open }π{ 920130.2145 Slack filespace bug removed }π{ Db3_sort implemented (based on shakersort)}π{ Bug in Db3_date2field removed }π{ 920716.2130 Empty file pack fixed in Db3_pack }π{ 920928.2200 Obscure bug in Db3_fieldname. Fieldnames }π{ seem to be are ASCIZ in stead of fixed }π{ length strings. }π{ 930927.2000 Freemem bug in db3_findnext corrected. }π{---------------------------------------------------------}π{ To Do Full Documentation }π{ Write Memo Support }π{ Extend Db3_pack with MemoFile Packing }π{ Sort *.DBF in place }π{ Insert record in *.DBF file }π{ Date format not always yy-mm-dd }π{---------------------------------------------------------}ππUNIT Db3_01;ππINTERFACEππUSESπ DOS;ππ{---------------------------------------------------------}π{----Error Handling : Returns First Error Which Occured }π{---------------------------------------------------------}ππVARπ db3_ernr : INTEGER; {----DB3 Module Error Code}π db3_fatal : BOOLEAN; {----IF Trueπ THEN Halt(db3_ernr)π on an error}ππ db3_memotext : TEXT; {----Memo File}ππ{---------------------------------------------------------}ππFUNCTION Db3_ermsg(nr : INTEGER) : STRING;ππ{---------------------------------------------------------}π{----Initialize/Exit : Must both be Called for every file }π{---------------------------------------------------------}ππPROCEDURE Db3_open(fn : STRING); {----Opens fn.DBF file &π Inits Internals}πPROCEDURE Db3_close; {----Closes fn.DBF file}ππ{---------------------------------------------------------}π{----Header Function : Get .DBF header info }π{---------------------------------------------------------}ππFUNCTION Db3_memo : BOOLEAN;ππFUNCTION Db3_update : STRING;ππFUNCTION Db3_norecs : LONGINT;ππFUNCTION Db3_nofields : INTEGER;ππFUNCTION Db3_reclen : INTEGER;ππ{---------------------------------------------------------}π{----File I/O : Dbase III Alike (pos etc. in records) }π{---------------------------------------------------------}ππPROCEDURE Db3_seek(pos : LONGINT);ππFUNCTION Db3_filesize : LONGINT;ππFUNCTION Db3_filepos : LONGINT;ππPROCEDURE Db3_readnext;ππPROCEDURE Db3_read(pos : LONGINT);ππPROCEDURE Db3_seekeof;ππPROCEDURE Db3_seekbof;ππFUNCTION Db3_eof : BOOLEAN;ππFUNCTION Db3_bof : BOOLEAN;ππPROCEDURE Db3_replace(no : LONGINT); {----First Read record &π Fill all fields}πPROCEDURE Db3_append; {----First Fill all Fields}ππPROCEDURE Db3_delete(no : LONGINT);ππPROCEDURE Db3_undelete(no : LONGINT);ππPROCEDURE Db3_pack; {----Packs File IN-PLACE}ππPROCEDURE Db3_blankrec;ππ{---------------------------------------------------------}π{----Field Operations : no is .DBF field number }π{---------------------------------------------------------}ππFUNCTION Db3_fieldname(no : INTEGER) : STRING;ππFUNCTION Db3_fieldlen(no : INTEGER) : INTEGER;ππFUNCTION Db3_fielddec(no : INTEGER) : INTEGER;ππFUNCTION Db3_fieldno(name : STRING) : INTEGER; {----Searches Fieldnumber forπ Uppercase fieldname}πFUNCTION Db3_fieldtype(no : INTEGER) : CHAR;ππFUNCTION Db3_deleted : BOOLEAN;ππ{---------------------------------------------------------}π{----Field Conversions : date format 'dd-mm-19yy' }π{---------------------------------------------------------}ππFUNCTION Db3_field2str(no :INTEGER) : STRING;ππFUNCTION Db3_field2char(no :INTEGER) : CHAR;ππFUNCTION Db3_field2logic(no : INTEGER) : BOOLEAN;ππFUNCTION Db3_field2num(no : INTEGER) : REAL;ππFUNCTION Db3_field2date(no :INTEGER) : STRING;ππPROCEDURE Db3_field2memo(no : INTEGER);ππFUNCTION Db3_field2soundex(no : INTEGER) : STRING;ππPROCEDURE Db3_str2field(no :INTEGER;s : STRING);ππPROCEDURE Db3_char2field(no :INTEGER;s : CHAR);ππPROCEDURE Db3_logic2field(no : INTEGER;l : BOOLEAN);ππPROCEDURE Db3_num2field(no : INTEGER;n : REAL);ππPROCEDURE Db3_date2field(no :INTEGER;d : STRING);ππ{---------------------------------------------------------}π{----Database Search, spaces are used as wildcards. }π{ Db3_blankrec can be used for creating a wildcard }π{ record. Then if Findfirst is true the use Findnext }π{ until Findnext becomes false. After each succesfull }π{ call the internal readbuffer will contain the }π{ matching record. Use casesense=true for a case }π{ sensitive search. }π{---------------------------------------------------------}ππFUNCTION Db3_findfirst(cs : BOOLEAN) : BOOLEAN;ππFUNCTION Db3_findnext(cs : BOOLEAN) : BOOLEAN;ππ{---------------------------------------------------------}π{----Soundex Code Function (sound alike) }π{---------------------------------------------------------}ππFUNCTION Db3_soundex(name : STRING) : STRING;ππFUNCTION Db3_firstsoundex(no : INTEGER; s : STRING) : BOOLEAN;ππFUNCTION Db3_nextsoundex(no : INTEGER; s : STRING) : BOOLEAN;ππ{---------------------------------------------------------}π{----Shaker Sort Almost Sorted *.DBF Files }π{---------------------------------------------------------}ππPROCEDURE Db3_sort(no : INTEGER);ππIMPLEMENTATIONππ{---------------------------------------------------------}π{----Error Handling }π{---------------------------------------------------------}ππPROCEDURE Seternr(e : INTEGER);ππBEGINπ IF (db3_ernr=0) THEN db3_ernr:=e;π IF db3_fatalπ THENπ BEGINπ Writeln;π Writeln('Db3_01 [Error : ',db3_ernr:0,' = '+Db3_ermsg(db3_ernr)+']');π Writeln;π IF (db3_ernr<>1) THEN Db3_close;π Halt(e);π END;πEND; {of Seternr}ππ{---------------------------------------------------------}ππFUNCTION Db3_ermsg(nr : INTEGER) : STRING;ππBEGINπ CASE nr OFπ 0 : Db3_ermsg:='No Error';π 1 : Db3_ermsg:='Error Opening File';π 2 : Db3_ermsg:='Seek Past EOF';π 3 : Db3_ermsg:='Seek Before BOF';π 4 : Db3_ermsg:='Read Past EOF';π 5 : Db3_ermsg:='Invalid Numeric Field';π 6 : Db3_ermsg:='Field Name NOT Found';π 7 : Db3_ermsg:='Invalid Header';π 8 : Db3_ermsg:='Incorrect Filesize';π 9 : Db3_ermsg:='Records to Large';π 10 : Db3_ermsg:='To many Fields';π 11 : Db3_ermsg:='Invalid Date Format';π 12 : Db3_ermsg:='Cannot Format Real';π 13 : Db3_ermsg:='Record was already deleted';π 14 : Db3_ermsg:='Record was not deleted';π 15 : Db3_ermsg:='NOT a Dbase III File';π 16 : Db3_ermsg:='Field Number NOT Found';π 17 : Db3_ermsg:='No Memofields in this file';π 18 : Db3_ermsg:='All matching records already found';π 19 : Db3_ermsg:='No *.DBF file open';π 20 : Db3_ermsg:='*.DBF already file open';π 99 : Db3_ermsg:='NOT Yet Implemented';π ELSE Db3_ermsg:='Unkown Error';π END;ππ db3_ernr:=0;πEND; {of Db3_ermsg}ππ{---------------------------------------------------------}π{----Types/Vars & Constants }π{---------------------------------------------------------}ππTYPEπ dbheader = RECORDπ dbvers : BYTE;π dbupdy,π dbupdm,π dbupdd : BYTE;π dbnorec: LONGINT;π dbheadl,π dbrecl : INTEGER;π dbres : ARRAY[1..20] OF BYTE;π END;ππ dbfield = RECORD {----Definition of Field Header}π dbname : ARRAY[1..11] OF CHAR;π dbtype : CHAR;π dbadr : LONGINT;π dblen,π dbdec : BYTE;π dbres : ARRAY[1..14] OF CHAR;π END;ππ fptr = RECORD {----Definition of Readbuf Index}π fppos : WORD;π fplen : BYTE;π END;ππCONSTπ maxfield = 60; {----Max number of Fields}π maxsize = 65000; {----Maximum Record Size}ππTYPEπ rectyp = ARRAY[0..maxsize] OF CHAR; {----Record Readbuffer Type}ππVARπ f : file; {----.DBF File}ππ header : dbheader; {----Space for Header}π nofields : INTEGER; {----Number of Fields}ππ fields : ARRAY[1..maxfield] OF dbfield; {----Field Definitions}π fieldptr : ARRAY[1..maxfield] OF fptr; {----Index into Readbuffer}π recstart : LONGINT; {----Start of Record Area}ππ dbrec : ^rectyp; {----Record Buffer}π reclen : WORD; {----Record Length}ππ memo : FILE; {----Memo File}π memopos : LONGINT; {----Location of Memo Record}π memobuf : ARRAY[1..512] OF CHAR; {----Memo Text File buffer}ππ dbsearch : ^rectyp; {----Search Record Buffer}ππ{---------------------------------------------------------}π{----Initialize }π{---------------------------------------------------------}ππPROCEDURE Db3_open(fn : STRING);ππVARπ i : INTEGER;π j : WORD;π ch : CHAR;ππBEGINπ IF (dbrec<>NIL)π THEN Seternr(20)π ELSEπ BEGINπ Assign(f,fn+'.DBF');π {$I-} Reset(f,1); {$I+}π IF (Ioresult<>0)π THEN Seternr(1)π ELSEπ BEGINπ {----Dump Header}π Blockread(f,header,32);ππ Getmem(dbrec,header.dbrecl+1);ππ {---Scan for Fieldnames & Recordlength}π reclen :=1;π nofields:=0;π Blockread(f,ch,1);π WHILE (nofields<maxfield) AND (ch<>#13) DOπ BEGINπ Inc(nofields);π WITH fields[nofields] DOπ BEGINπ dbname[1]:=ch;π Blockread(f,dbname[2],Sizeof(dbfield)-1);π Inc(reclen,dblen);π Blockread(f,ch,1);π END;π END;ππ IF (ch<>#13) THEN Seternr(10);ππ {----Zapped file contains only a EOF}π recstart:=Filepos(f);ππ {----Set fieldptr}π j:=1;π FOR i:=1 TO nofields DOπ WITH fieldptr[i],fields[i] DOπ BEGINπ fplen:=dblen;π fppos:=j;π Inc(j,dblen);π END;ππ {----Header Integrity Checks}π IF NOT(header.dbvers IN [$03,$83]) THEN Seternr(15);ππ IF ((header.dbheadl DIV 32)-1<>nofields) ORπ (header.dbrecl<>reclen)π THEN Seternr(7);ππ {----File Size Check}π IF (header.dbnorec*reclen<>(Filesize(f)-recstart-1))π THENπ BEGINπ {----Truncate DBASE Slack Filespace}π { Writeln('Truncating'); }π Db3_Seek(header.dbnorec+1);π {$I-} Seek(f,Filepos(f)+1); {$I+}π IF (IOresult=0)π THEN Truncate(f)π ELSE Seternr(8);π END;ππ IF (reclen>Sizeof(rectyp)) THEN Seternr(9);ππ IF Db3_memoπ THENπ BEGINπ Assign(memo,fn+'.DBT');π {$I-} Reset(memo,1); {$I+}π IF (IOresult<>0) THEN Seternr(17);π END;ππ IF (db3_ernr<>0) THEN Freemem(dbrec,header.dbrecl+1);π END;ππ IF (db3_ernr<>0)π THEN dbrec:=NILπ ELSE Db3_Seekbofππ END;πEND; {of Db3_open}ππ{---------------------------------------------------------}ππPROCEDURE Db3_close;ππVARπ y,m,d,dow : WORD;ππBEGINπ IF (dbrec<>NIL)π THENπ BEGINπ {----Update *.DBF File Header}π Getdate(y,m,d,dow);π WITH header DOπ BEGINπ dbupdy :=y MOD 100;π dbupdm :=m;π dbupdd :=d;π dbnorec:=Db3_filesize;π END;π Reset(f,1);π Blockwrite(f,header,32);π Close(f);ππ {----Cleanup Memory}π Freemem(dbrec,header.dbrecl+1);π IF dbsearch<>NIL THEN Freemem(dbsearch,header.dbrecl+1);ππ dbrec :=NIL;π dbsearch :=NIL;π ENDπ ELSE Seternr(19);πEND; {of DB3_close}ππ{---------------------------------------------------------}π{----Header Operations }π{---------------------------------------------------------}ππFUNCTION Db3_memo : BOOLEAN;ππBEGINπ Db3_memo:=header.dbvers=$83;πEND; {of Db3_memo}ππ{---------------------------------------------------------}ππFUNCTION Db3_update : STRING;ππVARπ s : STRING;ππBEGINπ s:='dd-mm-19yy';π s[ 1]:=Chr(Ord('0')+header.dbupdd DIV 10);π s[ 2]:=Chr(Ord('0')+header.dbupdd MOD 10);π s[ 4]:=Chr(Ord('0')+header.dbupdm DIV 10);π s[ 5]:=Chr(Ord('0')+header.dbupdm MOD 10);π s[ 9]:=Chr(Ord('0')+header.dbupdy DIV 10);π s[10]:=Chr(Ord('0')+header.dbupdy MOD 10);ππ Db3_update:=s;πEND; {of Db3_update}ππ{---------------------------------------------------------}ππFUNCTION Db3_norecs : LONGINT;ππBEGINπ Db3_norecs:=header.dbnorec;πEND; {of Db3_norecs}ππ{---------------------------------------------------------}ππFUNCTION Db3_nofields : INTEGER;ππBEGINπ Db3_nofields:=nofields;πEND; {of Db3_nofields}ππ{---------------------------------------------------------}ππFUNCTION Db3_reclen : INTEGER;ππBEGINπ Db3_reclen:=reclen;πEND; {of Db3_reclen}ππ{---------------------------------------------------------}π{----File I/O }π{---------------------------------------------------------}ππPROCEDURE Db3_seek(pos : LONGINT);ππBEGINπ {$I-} Seek(f,recstart+(pos-1)*reclen); {$I+}π IF (Ioresult<>0) OR (pos<1) OR (pos>Db3_filesize+1)π THENπ BEGINπ IF (pos>0)π THEN Seternr(2)π ELSE Seternr(3);π END;πEND; {of Db3_seek}ππ{---------------------------------------------------------}ππFUNCTION Db3_filesize : LONGINT;ππBEGINπ Db3_filesize:=(Filesize(f)-recstart) DIV reclen;πEND; {of Db3_filesize}ππ{---------------------------------------------------------}ππFUNCTION Db3_filepos : LONGINT;ππBEGINπ Db3_filepos:=((Filepos(f)-recstart) DIV reclen)+1;πEND; {of Db3_filepos}ππ{---------------------------------------------------------}ππPROCEDURE Db3_readnext;ππBEGINπ IF EOF(f) OR Db3_Eofπ THEN Seternr(4)π ELSE Blockread(f,dbrec^,reclen);πEND; {of Db3_readnext}ππ{---------------------------------------------------------}ππPROCEDURE Db3_read(pos : LONGINT);ππBEGINπ Db3_seek(pos);π Db3_readnext;πEND; {of Db3_read}ππ{---------------------------------------------------------}ππPROCEDURE Db3_seekeof;ππBEGINπ Db3_Seek(Db3_filesize+1);πEND; {of Db3_seekeof}ππ{---------------------------------------------------------}ππPROCEDURE Db3_seekbof;ππBEGINπ Seek(f,recstart);πEND; {of Db3_seekeof}ππ{---------------------------------------------------------}ππFUNCTION Db3_eof : BOOLEAN;ππBEGINπ Db3_eof:=(Filepos(f)>=Filesize(f)-1);πEND; {of Db3_eof}ππ{---------------------------------------------------------}ππFUNCTION Db3_bof : BOOLEAN;ππBEGINπ Db3_bof:=Filepos(f)=recstart;πEND; {of Db3_bof}ππ{---------------------------------------------------------}ππPROCEDURE Db3_replace(no : LONGINT);ππBEGINπ Db3_seek(no);π IF (db3_ernr=0) THEN Blockwrite(f,dbrec^[0],reclen)πEND; {of Db3_append}ππ{---------------------------------------------------------}ππPROCEDURE Db3_append;ππVARπ ch : CHAR;ππBEGINπ Db3_seek(Db3_filesize+1);π Blockwrite(f,dbrec^[0],reclen);π ch:=^Z;π Blockwrite(f,ch,1);π Db3_seek(Db3_filesize+1);πEND; {of Db3_append}ππ{---------------------------------------------------------}ππPROCEDURE Db3_delete(no : LONGINT);ππBEGINπ Db3_read(no);π IF dbrec^[0]='*'π THEN Seternr(13)π ELSE dbrec^[0]:='*';π Db3_replace(no)πEND; {of Db3_delete}ππ{---------------------------------------------------------}ππPROCEDURE Db3_undelete(no : LONGINT);ππBEGINπ Db3_read(no);π IF dbrec^[0]=' 'π THEN Seternr(14)π ELSE dbrec^[0]:=' ';π Db3_replace(no)πEND; {of Db3_undelete}ππ{---------------------------------------------------------}ππPROCEDURE Db3_pack;ππVARπ i,j : LONGINT;π ch : CHAR;ππBEGINπ j:=0;π FOR i:=1 TO Db3_filesize DOπ BEGINπ Db3_read(i);π IF NOT(Db3_deleted)π THENπ BEGINπ Inc(j);π Db3_replace(j)π ENDπ END;ππ{----New EOF Marker}π IF (j=0)π THEN db3_SeekBofπ ELSE Db3_read(j);π ch:=^Z;π Blockwrite(f,ch,1);π Truncate(f);ππ Db3_seek(1);πEND; {of Db3_pack}ππ{---------------------------------------------------------}ππPROCEDURE Db3_blankrec;ππVARπ i : INTEGER;ππBEGINπ FOR i:=0 TO reclen-1 DO dbrec^[i]:=#32;πEND; {of Db3_blankrec}ππ{---------------------------------------------------------}π{----Field Operations }π{---------------------------------------------------------}ππFUNCTION Db3_fieldname(no : INTEGER) : STRING;ππVARπ s : STRING;π i : WORD;ππBEGINπ s:='';π i:=1;π IF no IN [1..nofields]π THENπ BEGINπ WITH fields[no] DOπ WHILE (i<=Sizeof(dbname)) AND (dbname[i]<>#0) DOπ BEGINπ s:=s+dbname[i];π Inc(i);π END;π ENDπ ELSE Seternr(16);π Db3_fieldname:=s;πEND; {of Db3_fieldname}ππ{---------------------------------------------------------}ππFUNCTION Db3_fieldlen(no : INTEGER) : INTEGER;ππBEGINπ Db3_fieldlen:=0;π IF no IN [1..nofields]π THEN Db3_fieldlen:=fields[no].dblenπ ELSE Seternr(16);πEND; {of Db3_fieldlen}ππ{---------------------------------------------------------}ππFUNCTION Db3_fielddec(no : INTEGER) : INTEGER;ππBEGINπ Db3_fielddec:=0;π IF no IN [1..nofields]π THEN Db3_fielddec:=fields[no].dbdecπ ELSE Seternr(16)πEND; {of Db3_fielddec}ππ{---------------------------------------------------------}ππFUNCTION Db3_fieldno(name : STRING) : INTEGER;ππVARπ i,j : INTEGER;π s : STRING;ππBEGINπ Db3_fieldno:=0;ππ s:=name;π FOR i:=1 TO Length(s) DO s[i]:=Upcase(s[i]);ππ i:=1;π WHILE (i<=nofields) AND (s<>Db3_fieldname(i)) DOπ Inc(i);ππ IF (i>nofields)π THEN Seternr(6)π ELSE Db3_fieldno:=i;πEND; {of Db3_fieldno}ππ{---------------------------------------------------------}ππFUNCTION Db3_fieldtype(no : INTEGER) : CHAR;ππBEGINπ Db3_fieldtype:=#00;π IF no IN [1..nofields]π THEN Db3_fieldtype:=fields[no].dbtypeπ ELSE Seternr(16);πEND; {of Db3_fieldtype}ππ{---------------------------------------------------------}ππFUNCTION Db3_deleted : BOOLEAN;ππBEGINπ Db3_deleted:=dbrec^[0]<>#32;πEND; {of Db3_deleted}ππ{---------------------------------------------------------}π{----Field Conversions }π{---------------------------------------------------------}ππFUNCTION Db3_field2str(no :INTEGER) : STRING;ππVARπ s : STRING;π i : WORD;ππBEGINπ s:='';π IF (no IN [1..nofields])π THENπ BEGINπ s[0]:=Chr(fieldptr[no].fplen);π Move(dbrec^[fieldptr[no].fppos],s[1],fieldptr[no].fplen);π ENDπ ELSE Seternr(16);π{----Strip Trailing Spaces}π WHILE (Length(s)>0) AND (s[Length(s)]=#32) DO Dec(s[0]);π Db3_field2str:=s;πEND; {of Db3_field2str}ππ{---------------------------------------------------------}ππFUNCTION Db3_field2char(no :INTEGER) : CHAR;ππVARπ s : STRING;ππBEGINπ IF (Db3_fieldlen(no)=1)π THEN s:=Db3_field2str(no)π ELSE s:=#00;ππ IF (Length(s)=0)π THEN Db3_field2char:=#32π ELSE Db3_field2char:=s[1];πEND; {of Db3_field2char}ππ{---------------------------------------------------------}ππFUNCTION Db3_field2logic(no : INTEGER) : BOOLEAN;ππBEGINπ Db3_field2logic:=(Db3_field2char(no)='T');πEND; {of Db3_field2logic}ππ{---------------------------------------------------------}ππFUNCTION Db3_field2num(no : INTEGER) : REAL;ππVARπ r : REAL;π s : STRING;π e : INTEGER;ππBEGINπ s:=Db3_field2str(no);π WHILE (Length(s)>0) AND (s[1]=#32) DO Delete(s,1,1);π Val(s,r,e);π IF (e<>0)π THEN Seternr(5);π Db3_field2num:=r;πEND; {of Db3_field2num}ππ{---------------------------------------------------------}ππFUNCTION Db3_field2date(no :INTEGER) : STRING;ππVARπ s : STRING;ππBEGINπ s:='dd-mm-yyyy';π IF (no IN [1..nofields])π THENπ BEGINπ Move(dbrec^[fieldptr[no].fppos+6],s[1],2);π Move(dbrec^[fieldptr[no].fppos+4],s[4],2);π Move(dbrec^[fieldptr[no].fppos+0],s[7],4);π ENDπ ELSE Seternr(16);ππ Db3_field2date:=s;πEND; {of Db3_field2date}ππ{---------------------------------------------------------}ππFUNCTION Db3_field2soundex(no : INTEGER) : STRING;ππBEGINπ Db3_field2soundex:=Db3_soundex(Db3_field2str(no));πEND; {of Db3_field2soundex}ππ{---------------------------------------------------------}ππPROCEDURE Db3_str2field(no :INTEGER;s : STRING);ππBEGINπ IF (no IN [1..nofields])π THENπ BEGINπ Fillchar(dbrec^[fieldptr[no].fppos],fieldptr[no].fplen,#32);π WITH fields[no] DOπ IF (Length(s)>dblen)π THEN Move(s[1],dbrec^[fieldptr[no].fppos],dblen)π ELSE Move(s[1],dbrec^[fieldptr[no].fppos],Length(s));π ENDπ ELSE Seternr(16)πEND; {of Db3_str2field}ππ{---------------------------------------------------------}ππPROCEDURE Db3_char2field(no :INTEGER;s : CHAR);ππBEGINπ Db3_str2field(no,s);πEND; {of Db3_char2field}ππ{---------------------------------------------------------}ππPROCEDURE Db3_logic2field(no : INTEGER;l : BOOLEAN);ππBEGINπ IF lπ THEN Db3_char2field(no,'T')π ELSE Db3_char2field(no,'F')πEND; {of Db3_logic2field}ππ{---------------------------------------------------------}ππPROCEDURE Db3_num2field(no : INTEGER;n: REAL);ππVARπ s : STRING;ππBEGINπ IF (no IN [1..nofields])π THENπ BEGINπ Str(n:fields[no].dblen:fields[no].dbdec,s);π IF (Length(s)>fields[no].dblen)π THEN Seternr(12)π ELSE Db3_str2field(no,s);π ENDπ ELSE Seternr(16)πEND; {of Db3_num2field}ππ{---------------------------------------------------------}ππPROCEDURE Db3_date2field(no :INTEGER;d : STRING);ππVARπ s : STRING;ππBEGINπ IF (Length(d)<>10) ORπ (d[3]<>'-') ORπ (d[6]<>'-')π THEN Seternr(11)π ELSEπ BEGINπ {----dd-mm-yyyy}π s[1]:=d[ 7];π s[2]:=d[ 8];π s[3]:=d[ 9];π s[4]:=d[10];π s[5]:=d[ 4];π s[6]:=d[ 5];π s[7]:=d[ 1];π s[8]:=d[ 2];π Db3_str2field(no,s);π END;πEND; {of Db3_date2field}ππ{---------------------------------------------------------}π{----Memo text field support }π{---------------------------------------------------------}ππ{$F+}ππFUNCTION memoignore(VAR f : textrec) : INTEGER;ππBEGINπ memoignore:=0;πEND; {of memoignore}ππ{---------------------------------------------------------}ππFUNCTION memoinput(VAR f : textrec) : INTEGER;ππVARπ chread : WORD;ππBEGINπ WITH Textrec(f) DOπ BEGINπ Blockread(memo,memobuf[1],Sizeof(memobuf),chread);π bufpos :=0;π bufend :=chread;π END;π memoinput:=0;πEND; {of memoinput}ππ{$F-}ππ{---------------------------------------------------------}ππPROCEDURE Assignmemo(VAR f : TEXT);ππVARπ chread : WORD;ππCONSTπ fminput =$D7B1;ππBEGINπ WITH Textrec(f) DOπ BEGINπ handle :=$ffff;π mode :=fminput;π bufsize :=SIZEOF(memobuf);π bufpos :=0;π bufptr :=@memobuf;ππ Blockread(memo,memobuf[1],Sizeof(memobuf),chread);π bufpos :=0;π bufend :=chread;ππ openfunc :=@memoignore;π inoutfunc:=@memoinput;π flushfunc:=@memoignore;π closefunc:=@memoignore;π name[0] :=#00;π END;πEND; {of Assignmemo}ππ{---------------------------------------------------------}ππPROCEDURE Db3_field2memo(no : INTEGER);ππVARπ e : INTEGER;π s : STRING;ππBEGINπ IF Db3_memoπ THENπ BEGINπ s:=Db3_field2str(no);π WHILE (Length(s)>0) AND (s[1]=#32) DO Delete(s,1,1);π Val(s,memopos,e);π IF (e<>0)π THEN Seternr(5)π ELSEπ BEGINπ Seek(memo,memopos*Sizeof(memobuf));π Assignmemo(db3_memotext);π END;π ENDπ ELSE Seternr(17);πEND; {of Db3_field2memo}ππ{---------------------------------------------------------}ππFUNCTION Db3_findfirst(cs : BOOLEAN) : BOOLEAN;ππVARπ match,π found : BOOLEAN;π i : INTEGER;ππBEGINπ Getmem(dbsearch,Db3_reclen+1);π Move(dbrec^,dbsearch^,Db3_reclen);ππ Db3_Seekbof;ππ found:=False;π WHILE NOT(found OR Db3_eof OR (Db3_ernr<>0)) DOπ BEGINπ Db3_readnext;ππ i:=0;π match:=true;π WHILE (i<Db3_reclen) AND match DOπ BEGINπ IF (dbsearch^[i]<>#32)π THENπ CASE cs OFπ TRUE : match:=( dbsearch^[i] = dbrec^[i]);π FALSE : match:=(Upcase(dbsearch^[i])=Upcase(dbrec^[i]));π END;π INC(i);π END;π found:=match;π END;ππ Db3_findfirst:=found;ππ IF (found=False)π THENπ BEGINπ Freemem(dbsearch,Db3_reclen+1);π dbsearch:=NIL;π END;πEND; {of Db3_findfirst}ππ{---------------------------------------------------------}ππFUNCTION Db3_findnext(cs : BOOLEAN) : BOOLEAN;ππVARπ match,π found : BOOLEAN;π i : INTEGER;ππBEGINπ IF (dbsearch=NIL)π THEN Seternr(18);ππ found:=False;π WHILE NOT(found OR Db3_eof OR (Db3_ernr<>0)) DOπ BEGINπ Db3_readnext;ππ i:=0;π match:=true;π WHILE (i<Db3_reclen) AND match DOπ BEGINπ IF (dbsearch^[i]<>#32)π THENπ CASE cs OFπ TRUE : match:=( dbsearch^[i] = dbrec^[i]);π FALSE : match:=(Upcase(dbsearch^[i])=Upcase(dbrec^[i]));π END;π INC(i);π END;π found:=match;π END;ππ Db3_findnext:=found;ππ If (found=False) AND (dbsearch<>NIL)π Thenπ BEGINπ Freemem(dbsearch,Db3_reclen+1);π dbsearch:=NIL;π END;πEND; {of Db3_findnext}ππ{---------------------------------------------------------}ππFUNCTION Db3_soundex(name : STRING) : STRING;ππVARπ work : STRING;π code : CHAR;π i,j : INTEGER;ππ {---------------------------------------------------------}ππ FUNCTION Encode(VAR c: CHAR): CHAR;ππ BEGINπ CASE Upcase(c) OFπ 'B','F','P','V': encode:='1';π 'C','G','J','K','Q','S','X','Z': encode:='2';π 'D','T': encode:='3';π 'L': encode:='4';π 'M','N': encode:='5';π 'R': encode:='6';π 'A','E','I','O','U','Y': encode:='7';π 'H','W': encode:='8';π ELSE encode:=' ';π END;π END; {of Encode}ππ {---------------------------------------------------------}ππBEGINπ{----If we can't calculate, this is the answer}π work:='';ππ{----Skip all non alpha codes in front}π i:=1;π WHILE (i<=Length(name)) AND (Encode(name[i])=' ') DO Inc(i);ππ{----If any alpha characters left, start calculating the SOUNDEX code}π IF (i<=Length(name))π THENπ BEGINπ {----The first alpha letter of string is the first letter of the code}π work:=Upcase(name[i]);π Inc(i);ππ {----Be sure while loop precondition is correct}π j:=1;π code:=#00;ππ {----Calculate the numeric part of the code, }π { with a maximum of 3 digits, stop if a non }π { alpha character is encountered }π WHILE (i<=Length(name)) AND (j<=3) AND (code<>' ') DOπ BEGINπ code:=Encode(name[i]);ππ {----If new code group then add the goup number}π IF (code IN ['1'..'6']) AND (work[j]<>code)π THENπ BEGINπ Inc(j);π work:=work+code;π END;π Inc(i);π END;π END;ππ{----Return the resulting SOUNDEX code}π Db3_soundex:=work;ππEND; {of Db3_soundex}ππ{---------------------------------------------------------}ππFUNCTION Db3_firstsoundex(no : INTEGER;s : STRING) : BOOLEAN;ππVARπ found : BOOLEAN;π sdx : STRING;ππBEGINπ Db3_Seekbof;ππ sdx:=Db3_soundex(s);ππ found:=False;π WHILE NOT(found OR Db3_eof OR (Db3_ernr<>0)) DOπ BEGINπ Db3_readnext;π found:=(Pos(sdx,Db3_field2soundex(no))=1);π END;ππ Db3_firstsoundex:=found;πEND; {of Db3_firstsoundex}ππ{---------------------------------------------------------}ππFUNCTION Db3_nextsoundex(no : INTEGER; s : STRING) : BOOLEAN;ππVARπ found : BOOLEAN;π sdx : STRING;ππBEGINπ sdx:=Db3_soundex(s);ππ found:=False;π WHILE NOT(found OR Db3_eof OR (Db3_ernr<>0)) DOπ BEGINπ Db3_readnext;π found:=(Pos(sdx,Db3_field2soundex(no))=1);π END;ππ Db3_nextsoundex:=found;πEND; {of Db3_nextsoundex}ππ{---------------------------------------------------------}ππPROCEDURE Db3_sort(no : INTEGER);ππVARπ dbsort : ^rectyp;π swapped : BOOLEAN;π i,j,l,r : LONGINT;π s1,s2 : STRING;π typ : CHAR;ππ {---------------------------------------------------------}ππ PROCEDURE Swap(r1,r2 : LONGINT);ππ BEGINπ {----Side Effects}π i:=j;π swapped:=True;ππ {----the Swapping itself}π Db3_replace(r1);π Move(dbsort^,dbrec^,Db3_reclen);π Db3_replace(r2);π END; {of Swapped}ππ {---------------------------------------------------------}ππ FUNCTION Compare(VAR c1,c2 : STRING) : BOOLEAN;ππ VARπ i : INTEGER;π s : STRING;ππ BEGINπ CASE typ OFπ 'M',π 'N' : BEGINπ {----Insert spaces for correct numeric compare}π FOR i:=1 TO Db3_fieldlen(no)-Length(c1) DO Insert(#32,c1,i);π FOR i:=1 TO Db3_fieldlen(no)-Length(c2) DO Insert(#32,c2,i);π END;π 'L',π 'S',π 'C' : BEGINπ {----Convert to Uppercase for correct alpha compare}π FOR i:=1 TO Length(c1) Do c1[i]:=Upcase(c1[i]);π FOR i:=1 TO Length(c2) Do c2[i]:=Upcase(c2[i]);π END;π 'D' : ;π END;ππ {----Return TRUE if c2>c1}π Compare:=(c2>c1);π END; {of Compare}ππ {---------------------------------------------------------}ππBEGINπ{----Use ShakerSort on almost sorted *.DBF file}π Getmem(dbsort,Db3_reclen+1);π Move(dbrec^,dbsort^,Db3_reclen);ππ l:=2;π r:=Db3_filesize;π i:=r-1;ππ swapped:=TRUE;π typ :=Db3_fieldtype(no);ππ WHILE (l<=r) AND swapped DOπ BEGINπ swapped:=False;ππ {----Bubble Up}π FOR j:=r DOWNTO l DOπ BEGINπ {----Fetch record j-1 & save it}π Db3_read(j-1);π s2:=Db3_field2str(no);π Move(dbrec^,dbsort^,Db3_reclen);ππ {----Fetch record j}π Db3_read(j);π s1:=Db3_field2str(no);ππ {----Bubble}π IF Compare(s1,s2)π THEN Swap(j-1,j);π END;π l:=i+1;ππ {----Bubble Down}π IF swappedπ THENπ BEGINπ FOR j:=l TO r DOπ BEGINπ {----Fetch record j-1 & save it}π Db3_read(j-1);π s2:=Db3_field2str(no);π Move(dbrec^,dbsort^,Db3_reclen);ππ {----Fetch record j}π Db3_read(j);π s1:=Db3_field2str(no);ππ {----Bubble}π IF Compare(s1,s2)π THEN Swap(j-1,j);π END;π r:=i-1;π END;π END;ππ Freemem(dbsort,Db3_reclen+1);ππ Db3_seekbof;πEND; {of Db3_sort}ππ{---------------------------------------------------------}ππBEGINπ db3_ernr :=0;π db3_fatal:=False;π dbsearch :=NIL;π dbrec :=NIL;πEND.πππ{ DOCUMENTATION }ππDb3_01.PAS is written byππ Ir. G.W. van der Vegtπ Hondbroek 57π 6121 XB Born (L)ππand uploaded as public domain software because the author likes toπshare it with other Turbo Pascal Users. Please keep the source theπway it is and write extentions as separate units.ππThis unit provides read/write access to Dbase III (Plus) *.DBF files. Theπunit is uploaded as it is, the author is not responsible for any damgageπby programs using this module. The unit is, of course, tested.ππBefore using any of the Db3 routine a program shall call Db3_open toπinitialize the file internal buffers & info. When finishing the programπshould call Db3_close to close the file & cleanup the internal buffer.ππAll routines are documented so there's not much to say about them. Accessπto the DBF file is only allowed through this unit, so the file recordπisn't exported.ππRecords must be read by Db3_read or Db3_readnext, and written by Db3_appendπor Db3_replace. All record functions use LONGINTs as parameter for addressingπrecords in the file.ππWhen a record is read, one can read the field in the record by using theπrecord number as parameter of the Db3_field2 procedures. This recordπnumber lies between 1 and maxfield. If one 's to be independend of theπlocation of the record the Db3_fieldno can be used to convert a fieldπname to the field number.ππWhen writing records fill all field with Db3_2field routines and don'tπforget to use Db3_undelete to initialize the deleted marker. It's ofπcourse also possible to read a record, modify some field and replace it.ππThe Db3_pack routine packs the file in-place, so no temp file is created.ππThis unit can't create DBase III *.DBF files as it can't write the fileπheader & fieldefinitions. It's also impossble to change the structure ofπa DBase III *.DBF database with it. This is done to keep the unit simple.πCreating & modifing databases is much easier in Dbase III Language.ππThis unit uses a special naming convention to be sure there's noπconfict with procedures from other units. All exported names haveπa three letter prefix Db3_. The 01 in the Unit name is a uniqueπversion number.π 5 08-24-9413:45ALL STEVE ROGERS Frequency Analyzer SWAG9408 !(╡° 27 èo {πJL> #2: Another thing, I've got this cool Lotto program where I would like toπ > a date file where the user can enter the weeks winning lotto numbers, thenπ > after a collection of weeks is made (say 10), the computer will read all tπ > numbers in the file and compile a list of the most frequently ocurring numπ > and print them out to the screen. I'm having trouble reading from and writπ > to the file. (I'll tackle the list compiling once that is straightened outπ > help?ππ Oh Boy, Lotto programs, the concept is pregnant with possibilities!π Ever wonder why someone with a lotto program would sell it and notπ just win all the lottos? :)ππ Ok, you want a frequency analyzer. Here's a start that will let youπ enter numbers and give a frequency table of all the numbers to dateπ (hey, this is kinda fun, maybe I'll go into the lottery seminarπ bidness. Look out, Becky Paul!):π}ππ{$i-}πusesπ crt;ππconstπ MAX = 49;ππtypeπ tFreqArray= array[0..MAX] of word;ππvarπ freqArray : tFreqArray;ππ{----------------------}πprocedure InitFreqArray;π{ Read data file into array. If not found, zero all accumulators. }ππvarπ FreqF : file of tFreqArray;ππbeginπ assign(FreqF,'lotto.dat');π reset(FreqF);π if (ioresult=0) then beginπ read(Freqf,freqArray);π close(freqF);π end else fillchar(FreqArray,sizeof(FreqArray),0);πend;ππ{----------------------}πprocedure SaveFreqArray;πvarπ FreqF : file of tFreqArray;ππbeginπ assign(FreqF,'lotto.dat');π rewrite(FreqF);π write(Freqf,freqArray);π close(freqF);πend;ππ{----------------------}πprocedure PrintFrequencyTable;ππtypeπ tPickRec=recordπ Number : byte;π Freq : word;π end;π tPickArray=array[0..MAX] of tPickRec;ππvarπ PickArray : tPickArray;ππ{-----------}πprocedure SortPickArray;ππ{-----------}πprocedure Swap(One,TheOther : byte);πvarπ tmp : tPickRec;ππbeginπ tmp:= PickArray[One];π PickArray[One]:= PickArray[TheOther];π PickArray[TheOther]:= tmp;πend;ππ{----------}πvarπ i,j,min : byte;ππbeginπ for i:= 0 to pred(MAX) do beginπ min:= i;π for j:= succ(i) to MAX doπ if (PickArray[j].freq > PickArray[min].freq) then min:= j;π if (min>i) then Swap(i,min);π end;πend; {SortPickArray}ππ{--------}πvarπ i : byte;ππbeginπ for i:= 0 to MAX do with PickArray[i] do beginπ Number:= i;π Freq:= FreqArray[i];π end;ππ SortPickArray;π clrscr;π writeln;π writeln('Frequency Table:');π for i:= 0 to 9 doπ writeln(PickArray[i].Number :7,': ',PickArray[i].Freq :5,' ',π PickArray[i+10].Number:7,': ',PickArray[i+10].Freq:5,' ',π PickArray[i+20].Number:7,': ',PickArray[i+20].Freq:5,' ',π PickArray[i+30].Number:7,': ',PickArray[i+30].Freq:5,' ',π PickArray[i+40].Number:7,': ',PickArray[i+40].Freq:5,' ');ππend; {PrintFrequencyTable}ππ{----------------------}πprocedure GetLottoNumbers;πvarπ OneNumber : byte;π Test : integer;π s : string;ππbeginπ PrintFrequencyTable;π repeatπ writeln;π write('Enter lotto number (<=',MAX,', Enter to quit): ');π readln(s);π if (s<>'') then beginπ val(s,OneNumber,test);π if (test=0) then beginπ inc(FreqArray[OneNumber]);π PrintFrequencyTable;π end;π end;π until (s='');ππend; {GetLottoNumbers}πbeginπ InitFreqArray;π GetLottoNumbers;π SaveFreqArray;πend.π 6 08-24-9413:48ALL KLAUS WIEGAND Re Anti-debugging...?? SWAG9408 ╘î!╝ 12 èo {π│ Now, just to bring this home, I want to make it take over theπ│ debugging interrupts. (INT 3, is it?) I am just wondering if thisπ│ has been done and if anyone has some TP/TASM code already created forπ│ this purpose.ππin case the debugger executes an int1 or int 3, all you will get is theπmessage "OOPS". not really secure, but for most cases QUITE good enough.ππ}ππUnit Nodebug;ππInterfaceππ{*************************************************}π{* *}π{* All actions will be handled by the *}π{* initialisation and the Exitprozedure *}π{* thus no exported declarations needed *}π{* *}π{*************************************************}ππImplementationππUses Dos,Crt;ππVarπ Oldint1,π Oldint3,π Exitsave : Pointer;ππ Procedure Donotdebug; Interrupt;π Beginπ Writeln ('OOPS?? pleeze no debuggung !!!!' );π Writeln;π Halt (255);π End;ππ{$F+}π Procedure Resetnodebug;π{$F-}π Beginπ Setintvec ( 1, Oldint1 );π Setintvec ( 3, Oldint3 );π Exitproc := Exitsave;π End;ππBeginπ Exitsave := Exitproc;π Exitproc := @Resetnodebug;π Getintvec ( 1, Oldint1 );π Getintvec ( 3, Oldint3 );π Setintvec ( 3, @Donotdebug );π Setintvec ( 1, @Donotdebug );πEnd.πππ 7 08-24-9413:51ALL ROBBIE FLYNN 'C' Printf SWAG9408 Γ¥6e 20 èo USES CRT,DOS;ππ(* Here is a procedure I made that does ABOUT the same thing as the 'C'π Printf Does. Could someone help me add a few more features? *)ππPROCEDURE Printf(Str : String);πVarπ X : Integer;π y : integer;π ky: char;π d : boolean;ππbeginπ d:=false;π x:=0;π ky:=' ';π for x:=1 to length(str) doπ beginπ ky:=str[x];π if (ky='\') and (not d) thenπ d:=trueπ Elseπ If (Ky='\') and (d) thenπ beginπ write('\');π d:=false;π endπ Elseπ if (ky='n') and (D) or (ky='N') And (D) thenπ beginπ writeln;π d:=false;π endπ elseπ if (Upcase(ky)='T') and (D) thenπ beginπ write(' ');π d:=false;π endπ elseπ if (Upcase(ky)='B') and (D) thenπ beginπ write(#8);π d:=false;π endπ elseπ if (Upcase(ky)='R') and (D) thenπ beginπ write(#13);π d:=false;π endπ elseπ if (Upcase(ky)='F') and (D) thenπ beginπ write(#12);π d:=false;π endππ elseπ if (Upcase(ky)='G') and (D) thenπ beginπ write(#7);π d:=false;π endππ elseππ if (not d) and (ky<>'\') thenπ beginπ write(ky);π d:=false;π end;ππ End;πEnd;ππBeginπ ClrScr;π Printf('This is a Printf() procedure. a \\n will make a new line.\nSee??');π Printf(' Making a \\\\ will display a \\. Try it! Make a \\\\n to make a');π printf('\nAlso, a \\b will back space. \\r will carriage return. \\f is f');π printf('.\n\\t is tab.\\gIs Beep Eg\tI just tabed.\n\rI just carriage ret');π printf('1234567890\b. There was a 0 after the 9. I backspased over it and');π Printf('\g\gI beeped twice by: \\g\\g\n\n\n\n');πEnd.ππππ 8 08-24-9413:55ALL ROLAND SKINNER Hand Scanner Code SWAG9408 └,¥Æ 112 èo unit RJScan;ππ{******************************}π{ }π{ RJScan }π{ }π{ v1.1 }π{ }π{ }π{ by }π{ }π{ Roland Skinner }π{ }π{ Copyright (c) 1992 }π{ }π{ RJS Software }π{ }π{ Released to the public }π{ domain 1994. }π{ }π{******************************}πππ{ Implements scanning ability for the DFI HS-3000 PLUS HANDY SCANNER or }π{ other 100% compatible hand-scanners (including certain GeniScans). }ππ{ NOTE - This unit may be overlayed. }π{ - This unit requires Turbo Pascal 6 (or above). }ππ{$B-,D-,F+,G-,I-,L-,O+,R-,S-,V-,X-}ππ{=============================================================================}ππinterfaceππ{-----------------------------------------------------------------------------}ππ constπ AnyResolution = 0;ππ{-----------------------------------------------------------------------------}ππ typeπ ScanError = (scOK,scNoScanner,scInvalidResolution,scIncorrectResolution,π scInvalidImageWidth);ππ{-----------------------------------------------------------------------------}ππ typeπ ScanLineBufferProc = function(LineNumber : Integer) : Pointer;π { NOTE - This function should return the address }π { of the scan-buffer for the "LineNumber"th }π { line. First line is number 0. }π DisplayScannedLineProc = procedure(LineNumber : Integer);π { NOTE - This procedure should display (if }π { necessary) the "LineNumber"th line }π { that was scanned in. First line is }π { number 0. }π StopScanningProc = function : Boolean;π { NOTE - This function should return "False", unless }π { some event has occurred which requires }π { scanning to stop. }ππ{-----------------------------------------------------------------------------}ππ function ScanImage(DesiredResolution,MaxLinesToScan,BytesPerLine : Integer;π ScanLineBuffer : ScanLineBufferProc;π DisplayScannedLine : DisplayScannedLineProc;π StopScanning : StopScanningProc) : ScanError;π {- This function will scan an image with width 8*"BytesPerLine" and }π { height "MaxLinesToScan". It is possible to specify the resolution at }π { which to scan the image in "DesiredResolution" (100,200,300,400). }π { If the resolution set on the scanner is different to that specified, }π { then the "scIncorrectResolution" error will be returned. }π { If "DesiredResolution" is "AnyResolution", then any resolution will }π { be allowed. "scInvalidResolution" will be returned if a resolution }π { other than 100,200,300,400 or "AnyResolution" is specified. }π { "ScanLineBuffer", "DisplayScannedLine" and "StopScanning" are }π { procedures/functions whose functions are discussed above. These must }π { be FAR procedures/functions. }π { If "BytesPerLine" is too large for the scanner-resolution, then }π { "scInvalidImageWidth" will be returned. }π { If scanner is not installed then "scNoScanner" is returned. }π { If successful, then "scOK" will be returned. }π { This function may not work with certain hand-scanners (if so, use }π { "GenericScanImage"). }π function GenericScanImage(MaxLinesToScan,BytesPerLine : Integer;π ScanLineBuffer : ScanLineBufferProc;π DisplayScannedLine : DisplayScannedLineProc;π StopScanning : StopScanningProc) : ScanError;π {- This function will scan an image in an analogous manner as }π { "ScanImage". However, it does not do any checks for valid resolution }π { or image-width. This is to allow compatibility for scanners which do }π { not allow for scan-resolution selection. }π { "scOK", "scNoScanner" and "scInvalidImageWidth" may be returned by }π { this function. Refer to "ScanImage" for a discussion about these. }π function ScannerIsInstalled : Boolean;π {- Returns installed-status of scanner. }π function ResolutionOfScanner : Integer;π {- Returns the resolution set on the scanner. If scanner is not }π { installed, then -1 will be returned. }π { This function may not work with certain hand-scanners. }ππ{=============================================================================}ππimplementationππ{-----------------------------------------------------------------------------}ππ constπ MaxBytesPerLine : Array[1..4] of Byte = (50,102,154,205);ππ{-----------------------------------------------------------------------------}ππ varπ ScannerInstalled : Boolean;π ScannerResolution : Word;π ScannerResolution100 : Byte;π DMAChannel : Byte;π DMAPageRegister : Word;π DMACurAddrRegister : Word;π DMACurWordCountRegister : Word;π DMAClearSingleMaskBit : Byte;π DMASetSingleMaskBit : Byte;π DMAModeRegisterSetting : Byte;π DMAWriteRequest : Byte;π DMATerminalCountReached : Byte;ππ{-----------------------------------------------------------------------------}ππ procedure DetermineScannerResolution; assembler;π varπ Data : Byte;π asmπ xor ax,axπ jmp @Startπ @ResSettings:π db 21h,41h,51h,71hπ @Start:π mov dx,27Bhπ mov cx,300π @1:π in al,dxπ and al,10000000bπ jnz @1π @2:π in al,dxπ and al,10000000bπ jz @2π loop @1π @3:π in al,dxπ and al,10000000bπ jnz @3π @4:π in al,dxπ and al,00100100bπ shr al,1π shr al,1π or ah,alπ shr al,1π shr al,1π or ah,alπ and ah,00000011bπ xor al,alπ xchg al,ahπ mov bl,4π sub bl,alπ mov al,blπ push axπ mov bx,OFFSET (@ResSettings-1)π add bx,axπ mov al,[cs:bx]π mov dx,27Ahπ out dx,alπ mov Data,alπ pop axπ mov ScannerResolution100,alπ mov cx,100π mul cxπ mov ScannerResolution,axπ end;ππ{-----------------------------------------------------------------------------}ππ procedure DetermineScannerDMA; assembler;π asmπ mov dx,27Bhπ in al,dxπ and al,00001010bπ cmp al,00001000bπ je @UseDMA1π cmp al,00000010bπ je @UseDMA3π jmp @NoDMAπ @UseDMA1:π mov DMAChannel,1π mov DMAPageRegister, 83hπ mov DMACurAddrRegister, 02hπ mov DMACurWordCountRegister,03hπ mov DMAClearSingleMaskBit, 00000001bπ mov DMASetSingleMaskBit, 00000101bπ mov DMAModeRegisterSetting, 01000101bπ mov DMAWriteRequest, 00000001bπ mov DMATerminalCountReached,00000010bπ jmp @Exitπ @UseDMA3:π mov DMAChannel,3π mov DMAPageRegister, 82hπ mov DMACurAddrRegister, 06hπ mov DMACurWordCountRegister,07hπ mov DMAClearSingleMaskBit, 00000011bπ mov DMASetSingleMaskBit, 00000111bπ mov DMAModeRegisterSetting, 01000111bπ mov DMAWriteRequest, 00000011bπ mov DMATerminalCountReached,00001000bπ jmp @Exitπ @NoDMA:π mov DMAChannel,0π @Exit:π end;ππ{-----------------------------------------------------------------------------}ππ procedure TurnScannerOn; assembler;π asmπ mov dx,27Ahπ mov al,01hπ out dx,alπ end;ππ{-----------------------------------------------------------------------------}ππ procedure TurnScannerOff; assembler;π asmπ mov dx,27Ahπ mov al,00hπ out dx,alπ end;ππ{-----------------------------------------------------------------------------}ππ procedure DMADelay; assembler;π asmπ nopπ nopπ nopπ end;ππ{-----------------------------------------------------------------------------}ππ function DoScan(MaxLinesToScan,BytesPerLine : Integer;π ScanLineBuffer : ScanLineBufferProc;π DisplayScannedLine : DisplayScannedLineProc;π StopScanning : StopScanningProc) : ScanError;π varπ LinesScanned : Integer;π ScanBuffer : Pointer;π WidthToScan : Word absolute BytesPerLine;π QuitScanning : Boolean;π beginπ if (BytesPerLine>0) and (BytesPerLine<=MaxBytesPerLine[ScannerResolution100]) thenπ beginπ LinesScanned := 0;π QuitScanning := False;π repeatπ ScanBuffer := ScanLineBuffer(LinesScanned);π asmπ {-Disable DMA transfer }π mov al,DMASetSingleMaskBitπ out 0Ah,alπ call DMADelay;π mov al,DMAModeRegisterSettingπ out 0Bh,alπ call DMADelayπ {-Setup Buffer address }π les di,ScanBufferπ mov dx,esπ mov al,dhπ mov cl,4π shl dx,clπ shr al,clπ add dx,diπ adc al,0π mov cx,dxπ mov dx,DMAPageRegisterπ out dx,alπ call DMADelayπ out 0Ch,alπ call DMADelayπ mov dx,DMACurAddrRegisterπ mov al,clπ out dx,alπ call DMADelayπ mov al,chπ out dx,alπ call DMADelayπ {-Setup bytes to transfer }π out 0Ch,alπ call DMADelayπ mov ax,WidthToScanπ dec axπ mov dx,DMACurWordCountRegisterπ out dx,alπ call DMADelayπ mov al,ahπ out dx,alπ {-Start DMA transfer }π mov dx,27Bhπ out dx,alπ dec dxπ in al,dx { DX = 027Ah }π mov al,DMAWriteRequestπ out 09h,alπ call DMADelayπ mov al,DMAClearSingleMaskBitπ out 0Ah,alπ end;π {-Scan line }π asmπ mov bl,DMATerminalCountReachedπ @1:π in al,08hπ and al,blπ cmp al,blπ je @2π push bxπ call StopScanningπ pop bxπ or al,alπ jz @1π mov QuitScanning,Trueπ @2:π end;π DisplayScannedLine(LinesScanned);π Inc(LinesScanned);π until (LinesScanned=MaxLinesToScan) or QuitScanning;π DoScan := scOK;π endπ elseπ DoScan := scInvalidImageWidth;π end;ππ{-----------------------------------------------------------------------------}ππ function ScanImage(DesiredResolution,MaxLinesToScan,BytesPerLine : Integer;π ScanLineBuffer : ScanLineBufferProc;π DisplayScannedLine : DisplayScannedLineProc;π StopScanning : StopScanningProc) : ScanError;π beginπ if ScannerInstalled thenπ beginπ if (DesiredResolution=AnyResolution) or ((DesiredResolution div 100) in [1..4]) thenπ beginπ TurnScannerOn;π DetermineScannerResolution;π if (DesiredResolution=AnyResolution) or (DesiredResolution=ScannerResolution) thenπ ScanImage := DoScan(MaxLinesToScan,BytesPerLine,π ScanLineBuffer,DisplayScannedLine,StopScanning)π elseπ ScanImage := scIncorrectResolution;π TurnScannerOff;π endπ elseπ ScanImage := scInvalidResolution;π endπ elseπ ScanImage := scNoScanner;π end;ππ{-----------------------------------------------------------------------------}ππ function GenericScanImage(MaxLinesToScan,BytesPerLine : Integer;π ScanLineBuffer : ScanLineBufferProc;π DisplayScannedLine : DisplayScannedLineProc;π StopScanning : StopScanningProc) : ScanError;π beginπ if ScannerInstalled thenπ beginπ TurnScannerOn;π ScannerResolution100 := 4;π GenericScanImage := DoScan(MaxLinesToScan,BytesPerLine,π ScanLineBuffer,DisplayScannedLine,StopScanning);π TurnScannerOff;π endπ elseπ GenericScanImage := scNoScanner;π end;ππ{-----------------------------------------------------------------------------}ππ procedure DetermineScannerPresence;π beginπ TurnScannerOn;π DetermineScannerDMA;π TurnScannerOff;π ScannerInstalled := (DMAChannel<>0);π end;ππ{-----------------------------------------------------------------------------}ππ function ScannerIsInstalled : Boolean;π beginπ ScannerIsInstalled := ScannerInstalled;π end;ππ{-----------------------------------------------------------------------------}ππ function ResolutionOfScanner : Integer;π beginπ if ScannerInstalled thenπ beginπ TurnScannerOn;π DetermineScannerResolution;π TurnScannerOff;π ResolutionOfScanner := ScannerResolution;π endπ elseπ ResolutionOfScanner := -1;π end;ππ{-----------------------------------------------------------------------------}ππbeginπ DetermineScannerPresence;πend.ππ{=============================================================================}π 9 08-24-9417:51ALL WIM VAN DER VEGT Smooth Thermobar display SWAG9408 rDq 39 èo {πHere a sample program which shows a smoothly (graphics mode like)πanimation of a thermobar display. It works (I think) only on VGA cardsππThe trick is done by animating one character by changing it'sπbitpattern. }πππ{---------------------------------------------------------}π{ Project : Textmode thermometer bar }π{ Unit : Main Program }π{ By : Wim van der Vegt }π{---------------------------------------------------------}π{ This program shows a thermometer bar display similar }π{ to the ones in many installation programs. This one }π{ however is in textmode, but smoothly animated as if in }π{ graphics mode. It is only tested on one (S)VGA card. }π{---------------------------------------------------------}π{ Date .Time Revision }π{ 940620.1450 Creation. }π{---------------------------------------------------------}ππUsesπ Dos,π Crt;ππConstπ c : Array[1..16] Of Byte = (255,255,255,255,π 255,255,255,255,π 255,255,255,255,π 255,255,255,255);ππ{---------------------------------------------------------}π{---Procedure to turn cursor on/off. }π{---------------------------------------------------------}ππProcedure Cursor(on : Boolean);ππVARπ r : registers;ππBEGINπ r.ah:=$03;π r.bh:=$00;π Intr($10,r);ππ IF ((r.cx< $2020) AND NOT(on)) ORπ ((r.cx>=$2020) AND on)π THENπ BEGINπ r.ah:=$01;π r.cx:=r.cx XOR $2020;π Intr($10,r);π END;πEND; {of Cursor}ππ{---------------------------------------------------------}π{---Procedure to wait for the vertical retrace of the VGA }π{ display. This minimizes screen flickering when the }π{ CRTC gets reprogrammed. }π{---------------------------------------------------------}ππPROCEDURE Wait4Retrace;ππbeginπ while ((Port[$3DA] AND 8) > 0) do;π while ((Port[$3DA] AND 8) = 0) do;πend; {of Wait4Retrace;}ππ{---------------------------------------------------------}π{---Procedure to generate an animation scene for character}π{ #1. The cursor is turned off every time the procedure }π{ is called because the cursor keeps showing up when the}π{ CRTC is reprogrammed. And a cursor behind a smoothly }π{ animated thermobar just doesn't feel right. }π{---------------------------------------------------------}ππProcedure Reprogram(i,bperc : Byte);ππVARπ j : integer;π r : registers;π w : Word;ππBeginπ{----calculate bittpattern. It goes likeπ 0π 128π 128+64π 128+64+32π 128+64+32+16π 128+64+32+16+8π 128+64+32+16+8+4π 128+64+32+16+8+4+2π 128+64+32+16+8+4+2+1 (This is equivalent to character 219 '█')π }ππ w:=0;π FOR j:=1 TO i DO w:=w+BYTE(256 SHR j);π For j:=1 To bperc Do c[j]:=w;ππ {----reprogram character #1,π but wait for retrace so there's no flickering}π r.ah:=$11;π r.al:=$10;π r.bh:=bperc;π r.bl:=$00;π r.cx:=$01;π r.dx:=$01;π r.bp:=Ofs(c);π r.es:=Seg(c);π Wait4Retrace;π Intr($10,r);π Cursor(false);πEnd; {of Reprogram}ππ{---------------------------------------------------------}π{---Main program, btw the character #1 isn't restored }π{ because it's seldomly used by application. }π{ a TEXTMODE(LASTMODE) statement will clear the screen }π{ and restore character #1. So put that at the end of }π{ program }π{---------------------------------------------------------}ππVarπ r : registers;π i,k : Byte;π bperc : Byte;ππBeginπ Clrscr;ππ GotoXY(20,5);π Write('0% 50% 100%');π GotoXY(20,4);ππ{----get bytes per character of current font,π by requesting font data on font #0 (INT 1F)}π r.ah:=$11;π r.al:=$30;π r.bh:=$00;π Intr($10,r);π bperc:=r.cx;ππ textcolor(yellow);ππ{----Do a 30 character bar}π For k:=1 To 40 Doπ Beginπ {----Use chr(1) to animate, however wipe it before writing it}π Reprogram(0,bperc);π Write(#01);ππ {----Animate character #1}π For i:=0 To 7 Doπ Beginπ {----calc bit new patterns,π bit patterns are reversed in character generator,π bit 7 is on the left side of a character}π Reprogram(i,bperc);π Delay(25);π End;ππ {----Replace fully animated characters by a full block fromπ the line drawing set because animation of character #1π will be started all over}π GotoXY(WhereX-1,WhereY);π Write('█');π End;π GotoXY(1,6);π Cursor(true);ππ {textmode(lastmode);}πEnd. {of Main program}π 10 08-25-9409:05ALL DAVE BELL Using C And Pascal - LinkSWAG9408 Nv¬ 40 èo (*πYK>1) I'm going to write a program in pascal that calls a function.πYK>2) That function is going to be written in C.πYK>3) Link them together to make one EXE file.ππYK>Is there anyway to do this or am I just dreaming? <g> Thanks forπYK>any insight in this.ππYes, it is possible. You will need to compile object code modules withπyour Pascal and C compilers, and then link them with a linker program.πUnusually, for a programming tool, the program you use for linking usuallyπhas the obvious name of LINK.EXE (as compared to such things as "grep",π"awk", "yacc" or "bison").ππThe second edition of Turbo C++ includes a set of example files for justπthis situation.ππFirst, a fragment of the C code called by the Pascal program.πππtypedef unsigned int word;πtypedef unsigned char byte;πtypedef unsigned long longword;ππextern void setcolor(byte newcolor); /* procedure defined inπ Turbo Pascal program */πextern word factor; /* variable declared in Turbo Pascal program */ππword sqr(int i)π{π setcolor(1);π return(i * i);π} /* sqr */ππword multbyfactor(word w)π{π setcolor(9); /* note that this function accesses the Turbo Pascal */π return(w * factor); /* declared variable factor */π} /* multbyfactor */ππ----8<---------ππThe command line compiler uses the following .CFG fileππ---8<---------ππ-wrvlπ-pπ-k-π-r-π-u-π-zCCODEπ-zPπ-zAπ-zRCONSTπ-zSπ-zTπ-zDDATAπ-zGπ-zBππ---8<------------ππFinally, the Pascal codeππ*)πprogram CPASDEMO;π(*π This program demonstrates how to interface Turbo Pascal and Turbo C++.π Turbo C++ is used to generate an .OBJ file (CPASDEMO.OBJ). Thenπ this .OBJ is linked into this Turbo Pascal program using the {$L}π compiler directive.ππ NOTES:π 1. Data declared in the Turbo C++ module cannot be accessed fromπ the Turbo Pascal program. Shared data must be declared inπ Pascal.ππ 2. If the C functions are only used in the implementation sectionπ of a unit, declare them NEAR. If they are declared in theπ interface section of a unit, declare them FAR. Always compileπ the Turbo C++ modules using the small memory model.ππ 3. Turbo C++ runtime library routines cannot be used because theirπ modules do not have the correct segment names. However, if youπ have the Turbo C++ runtime library source (available fromπ Borland), you can use individual library modules by recompilingπ them using Pascal conventions. If you do recompile them, makeπ sure that you include prototypes in your C module for all Cπ library functions that you use.ππ 4. Some of the code that Turbo C++ generates are calls to internalπ routines. These cannot be used without recompiling the relevantπ parts of the Turbo C++ runtime library source code.ππ In order to run this demonstration program you will need the followingπ files:ππ TCC.EXE and CTOPAS.CFG orπ TC.EXE and CTOPAS.TCππ To run the demonstration program CPASDEMO.EXE do the following:ππ 1. First create a CPASDEMO.OBJ file compatible with Turbo Pascal 4.0π or later using Turbo C++.ππ a) If you are using the Turbo C++ integrated environment (TC.EXE)π then at the DOS prompt execute:ππ TC CTOPAS.PRJππ then create the .OBJ file by pressing ALT-F9.ππ b) If you are using the Turbo C++ command line version (TCC.EXE)π then at the DOS prompt execute:ππ TCC +CTOPAS.CFG CPASDEMO.Cππ Note: Use the same configuration file (CTOPAS.CFG or CTOPAS.PRJ)π when you create your own Turbo C++ modules for use withπ Turbo Pascalππ 2. Compile and execute the Turbo Pascal program CPASDEMO.PASππ This simple program calls each of the functions defined in the Turbo C++π module. Each of the Turbo C++ functions changes the current display colorπ by calling the Turbo Pascal procedure SetColor. }π*)ππuses Crt;ππvarπ Factor : Word;ππ{$F+} { Force Far Calls for calling to and from Turbo C }ππ{$L CPASDEMO.OBJ} { link in the Turbo C++-generated .OBJ module }ππfunction Sqr(I : Integer) : Word; external;π{ Change the text color and return the square of I }ππfunction MultByFactor(W : Word) : Word; external;π{ Change the text color and return W * Factor - note Turbo C++'s access of }π{ Turbo Pascal's global variable. }ππprocedure SetColor(NewColor : Byte); { A procedure that changes the current }πbegin { display color by changing the CRT }π TextAttr := NewColor; { variable TextAttr }πend; { SetColor }ππbeginπ Writeln(Sqr(10)); { Call each of the functions defined }π { passing it the appropriate info.}ππ Factor :=100;π Writeln(MultbyFactor(10));π SetColor(LightGray);ππend.π{π------8<----------ππTo save space, I've edited a lot of the functions out of both sourceπfiles. I hope this works. I don't have a DOS Pascal compiler :(π}π 11 08-25-9409:07ALL GREG VIGNEAULT DOS + WorkGroups 3.11... SWAG9408 [Bô 3 èo {π TIP for DOS compiler users: If you've got Windows for WorkGroupsπ v3.11 with the 32-bit disk/file access enabled, compile your codeπ under a Windows "DOS box" instead of vanilla MS-DOS... you may cutπ the compiler file i/o time in half.π} 12 08-25-9409:13ALL MBOUSEK@INTEL9.INTEL.COM MS Excel XLOPER StructureSWAG9408 ╫àm( 52 èo (*π For reference... Here are the microsoft C and my borland Pascal versionsπof the Excel "xloper" structures. Thanks for the help!πNotes: 1) For each variant of the union in the C version of the xloperπtype there is a single comment starting "xlType...", "xlFlow...", ...πthese are actually integers from #define statements in the .H file. I'veπused these as selectors in my "record case ..." statements (and declaredπthem as "const" in my pascal source) and eliminated them from the comments.π2) A nice compare and contrast: Had microsoft put the xltype word (which isπat the end of the structure "xloper") first, I could have used it in my caseπselector as in "record case xltype:word of...", the two bytes that xltypeπoccupies would become somewhat of a runtime type selector (a definite pascalπadvantage) but on the other hand, by putting it at the end, the same addressπof this data item can directly typecast to one of the union's member typesπonce xltype has been examined (you do it by hand...) a C advantage (unlessπyou are using Borland Pascal :). 3) Since Pascal does not allow "unionsπwithin unions" or "variants of variants" I've declared each sub-unionπ(variant) as a separate type, which is legal pascal. Same effect. 4) I'veπtaken liberties in renaming some fields to make them more readable for me :}π5) The C version is 88 lines long, the Pascal one is 85. /*could it be theπthree lines I deleted from the comments???*/ππ*******************c version*****************************************ππ/*π** XLREF structureπ**π** Describes a single rectangular referenceπ*/ππtypedef struct xlrefπ{π WORD rwFirst;π WORD rwLast;π BYTE colFirst;π BYTE colLast;π} XLREF, FAR *LPXLREF;πππ/*π** XLMREF structureπ**π** Describes multiple rectangular references.π** This is a variable size structure, defaultπ** size is 1 reference.π*/ππtypedef struct xlmrefπ{π WORD count;π XLREF reftbl[1]; /* actually reftbl[count] */π} XLMREF, FAR *LPXLMREF;πππ/*π** XLOPER structureπ**π** Excel's fundamental data type: can hold dataπ** of any type. Use "R" as the argument type in theπ** REGISTER function.π**/ππtypedef struct xloperπ{π unionπ {π double num; /* xltypeNum */π LPSTR str; /* xltypeStr */π WORD bool; /* xltypeBool */π WORD err; /* xltypeErr */π short int w; /* xltypeInt */π structπ {π WORD count; /* always = 1 */π XLREF ref;π } sref; /* xltypeSRef */π structπ {π XLMREF far *lpmref;π DWORD idSheet;π } mref; /* xltypeRef */π structπ {π struct xloper far *lparray;π WORD rows;π WORD columns;π } array; /* xltypeMulti */π structπ {π unionπ {π short int level; /* xlflowRestart */π short int tbctrl; /* xlflowPause */π DWORD idSheet; /* xlflowGoto */π } valflow;π WORD rw; /* xlflowGoto */π BYTE col; /* xlflowGoto */π BYTE xlflow;π } flow; /* xltypeFlow */π structπ {π unionπ {π BYTE far *lpbData; /* data passed to XL */π HANDLE hdata; /* data returned from XL */π } h;π long cbData;π } bigdata; /* xltypeBigData */π } val;π WORD xltype;π} XLOPER, FAR *LPXLOPER;πππ*******************pascal version************************************π*)ππ{*π** XLREF structureπ** Describes a single rectangular referenceπ*}πtypeπ xlref_ptr = ^xlref_type;π xlref_type = recordπ FirstRow : word;π LastRow : word;π FirstCol : byte;π LastCol : byte;π end;ππ{*π** XLMREF structureπ** Describes multiple rectangular references.π** This is a variable size structure, defaultπ** size is 1 reference.π*}πtypeπ xlmref_ptr = ^xlmref_type;π xlmref_type = recordπ count : word; {count will never be more than 30 according to doc}π xlrefs : array[1..32] of xlref_type;π end;ππ{*π** XLOPER structureπ** Excel's fundamental data type: can hold dataπ** of any type. Use "R" as the argument type in theπ** REGISTER function.π**}πtypeπ flowarg_type = record case integer ofπ xlFlowRestart : ( level : integer; );π xlFlowPause : ( tbctrl : integer; );π xlFlowGoto : ( SheetId : longint; );π end;ππtypeπ handle_type = record case integer ofπ 1 : ( buff : pointer ); {*data passed to XL*}π 2 : ( hand : record {*data returned from XL*}π offset : word;π selector : word;π end; );π end;ππtypeπ xloper_ptr = ^xloper_type;π xloper_type = recordπ val : record case word ofπ xlTypeNum : ( num : double; );π xlTypestr : ( str : ^string; );π xlTypeBool : ( bool : word; );π xlTypeErr : ( err : word; );π xlTypeInt : ( int : integer; );π xlTypeSref : ( sref : recordπ count : word; {*always=1*}π xlref : xlref_type;π end; );π xlTypeRef : ( mref : recordπ xlmref : xlmref_ptr;π SheetId : longint;π end; );π xlTypeMulti : ( xlarray : recordπ xloper : xloper_ptr;π rows : word;π cols : word;π end; );π xlTypeFlow : ( flow : recordπ flowarg : flowarg_type;π row : word;π col : byte;π xlflow : byte;π end; );π xlTypeBigdata : ( bigdata : recordπ handle : handle_type;π len : longint;π end; );π end;π xltype : word;π end;πππππ
